{-# LANGUAGE AllowAmbiguousTypes  #-}
{-# LANGUAGE DefaultSignatures    #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE KindSignatures       #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE TypeOperators        #-}
{-# OPTIONS_HADDOCK hide #-}
-- |
-- Module      : Data.Array.Accelerate.Sugar.Tag
-- Copyright   : [2008..2020] The Accelerate Team
-- License     : BSD3
--
-- Maintainer  : Trevor L. McDonell <trevor.mcdonell@gmail.com>
-- Stability   : experimental
-- Portability : non-portable (GHC extensions)
--

module Data.Array.Accelerate.Sugar.Tag
  where

import Data.Array.Accelerate.Representation.Tag

import Data.Bits
import Data.Kind
import Language.Haskell.TH.Extra                                    hiding ( Type )

import GHC.Generics


-- | The numeric 'TAG' values corresponding to the constructors of the type @t@.
--
-- TODO: These tags are intended to be equal to the tags generated by
-- 'tagsR' from 'Elt'. (This is currently not programmatically checked.)
-- These should also be equal to the tags for sum-type patterns generated
-- using TemplateHaskell (which is also not programmatically checked).
--
class Tagged t where
  -- | The numeric 'TAG' values corresponding to the constructors of the
  -- type. The constructors are identified by their name as a String.
  tags :: [(String, TAG)]

  default tags :: GTagged (Rep t) => [(String, TAG)]
  tags = gtags @(Rep t) 0


class GTagged (f :: Type -> Type) where
  gtags :: TAG -> [(String, TAG)]

instance GTagged a => GTagged (D1 c a) where
  gtags = gtags @a

instance Constructor c => GTagged (C1 c a) where
  gtags k = [ (conName (undefined :: D1 c a ()), k) ]

instance (GTagged a, GTagged b) => GTagged (a :+: b) where
  gtags k =
    let as = gtags @a k
        bs = gtags @b k
     in
     map (\(x,y) -> (x,         y `shiftL` 1)   ) as ++
     map (\(x,y) -> (x, setBit (y `shiftL` 1) 0)) bs

instance Tagged ()
instance Tagged Bool
instance Tagged Ordering
instance Tagged (Maybe a)
instance Tagged (Either a b)

runQ $ do
  let
      mkTuple :: Int -> Q Dec
      mkTuple n =
        let xs  = [ mkName ('x' : show i) | i <- [0 .. n-1] ]
            ts  = map varT xs
            res = tupT ts
        in
        instanceD (return []) [t| Tagged $res |] []
  --
  mapM mkTuple [2..16]

